home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / share / autoconf / Autom4te / Channels.pm < prev    next >
Text File  |  2006-04-25  |  17KB  |  702 lines
  1. # Copyright (C) 2002 Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2, or (at your option)
  6. # any later version.
  7.  
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12.  
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  16. # 02111-1307, USA.
  17.  
  18. package Autom4te::Channels;
  19.  
  20. =head1 NAME
  21.  
  22. Autom4te::Channels - support functions for error and warning management
  23.  
  24. =head1 SYNOPSIS
  25.  
  26.   use Autom4te::Channels;
  27.  
  28.   # Register a channel to output warnings about unused variables.
  29.   register_channel 'unused', type => 'warning';
  30.  
  31.   # Register a channel for system errors.
  32.   register_channel 'system', type => 'error', exit_code => 4;
  33.  
  34.   # Output a message on channel 'unused'.
  35.   msg 'unused', "$file:$line", "unused variable `$var'";
  36.  
  37.   # Make the 'unused' channel silent.
  38.   setup_channel 'unused', silent => 1;
  39.  
  40.   # Turn on all channels of type 'warning'.
  41.   setup_channel_type 'warning', silent => 0;
  42.  
  43.   # Treat all warnings as errors.
  44.   $warnings_are_errors = 1;
  45.  
  46.   # Exit with the greater exist code encountered so far.
  47.   exit $exit_code;
  48.  
  49. =head1 DESCRIPTION
  50.  
  51. This perl module provides support functions for handling diagnostic
  52. channels in programs.  Channels can be registered to convey fatal,
  53. error, warning, or debug messages.  Each channel has various options
  54. (e.g. is the channel silent, should duplicate messages be removed,
  55. etc.) that can also be overridden on a per-message basis.
  56.  
  57. =cut
  58.  
  59. use 5.005;
  60. use strict;
  61. use Exporter;
  62. use Carp;
  63. use File::Basename;
  64.  
  65. use vars qw (@ISA @EXPORT %channels $me);
  66.  
  67. @ISA = qw (Exporter);
  68. @EXPORT = qw ($exit_code $warnings_are_errors
  69.           &reset_local_duplicates &reset_global_duplicates
  70.           ®ister_channel &msg &exists_channel &channel_type
  71.           &setup_channel &setup_channel_type
  72.           &dup_channel_setup &drop_channel_setup
  73.           &buffer_messages &flush_messages
  74.           US_GLOBAL US_LOCAL
  75.           UP_NONE UP_TEXT UP_LOC_TEXT);
  76.  
  77. $me = basename $0;
  78.  
  79. =head2 Global Variables
  80.  
  81. =over 4
  82.  
  83. =item C<$exit_code>
  84.  
  85. The greatest exit code seen so far. C<$exit_code> is updated from
  86. the C<exit_code> options of C<fatal> and C<error> channels.
  87.  
  88. =cut
  89.  
  90. use vars qw ($exit_code);
  91. $exit_code = 0;
  92.  
  93. =item C<$warnings_are_errors>
  94.  
  95. Set this variable to 1 if warning messages should be treated as
  96. errors (i.e. if they should update C<$exit_code>).
  97.  
  98. =cut
  99.  
  100. use vars qw ($warnings_are_errors);
  101. $warnings_are_errors = 0;
  102.  
  103. =back
  104.  
  105. =head2 Constants
  106.  
  107. =over 4
  108.  
  109. =item C<UP_NONE>, C<UP_TEXT>, C<UP_LOC_TEXT>
  110.  
  111. Possible values for the C<uniq_part> options.  This select the part
  112. of the message that should be considered when filtering out duplicates.
  113. If C<UP_LOC_TEXT> is used, the location and the explanation message
  114. are used for filtering.  If C<UP_TEXT> is used, only the explanation
  115. message is used (so the same message will be filtered out if it appears
  116. at different locations).  C<UP_NONE> means that duplicate messages
  117. should be output.
  118.  
  119. =cut
  120.  
  121. use constant UP_NONE => 0;
  122. use constant UP_TEXT => 1;
  123. use constant UP_LOC_TEXT => 2;
  124.  
  125. =item C<US_LOCAL>, C<US_GLOBAL>
  126.  
  127. Possible values for the C<uniq_scope> options.
  128. Use C<US_GLOBAL> for error messages that should be printed only
  129. once in the run of the program, C<US_LOCAL> for message that
  130. should be printed only once per file.  (Actually, C<Channels> does not
  131. now when files are changed, it relies on you calling C<reset_local_duplicates>
  132. when this happens.)
  133.  
  134. =cut
  135.  
  136. # possible values for uniq_scope
  137. use constant US_LOCAL => 0;
  138. use constant US_GLOBAL => 1;
  139.  
  140. =back
  141.  
  142. =head2 Options
  143.  
  144. Channels accept the options described below.  These options can be
  145. passed as a hash to the C<register_channel>, C<setup_channel>, and C<msg>
  146. functions.  The possible keys, with there default value are:
  147.  
  148. =over
  149.  
  150. =item C<type =E<gt> 'warning'>
  151.  
  152. The type of the channel.  One of C<'debug'>, C<'warning'>, C<'error'>, or
  153. C<'fatal'>.  Fatal messages abort the program when they are output.
  154. Error messages update the exit status.  Debug and warning messages are
  155. harmless, except that warnings can be treated as errors of
  156. C<$warnings_are_errors> is set.
  157.  
  158. =item C<exit_code =E<gt> 1>
  159.  
  160. The value to update C<$exit_code> with when a fatal or error message
  161. is emitted.  C<$exit_code> is also updated for warnings output
  162. when @<$warnings_are_errors> is set.
  163.  
  164. =item C<file =E<gt> \*STDERR>
  165.  
  166. The file where the error should be output.
  167.  
  168. =item C<silent =E<gt> 0>
  169.  
  170. Whether the channel should be silent.  Use this do disable a
  171. category of warning, for instance.
  172.  
  173. =item C<uniq_part =E<gt> UP_LOC_TEXT>
  174.  
  175. The part of the message subject to duplicate filtering.  See the
  176. documentation for the C<UP_NONE>, C<UP_TEXT>, and C<UP_LOC_TEXT>
  177. constants above.
  178.  
  179. =item C<uniq_scope =E<gt> US_LOCAL>
  180.  
  181. The scope of duplicate filtering.  See the documentation for the
  182. C<US_LOCAL>, and C<US_GLOBAL> constants above.
  183.  
  184. =item C<header =E<gt> ''>
  185.  
  186. A string to prepend to each message emitted through this channel.
  187.  
  188. =item C<footer =E<gt> ''>
  189.  
  190. A string to append to each message emitted through this channel.
  191.  
  192. =item C<backtrace =E<gt> 0>
  193.  
  194. Die with a stack backtrace after displaying the message.
  195.  
  196. =item C<partial =E<gt> 0>
  197.  
  198. When set, indicates a partial message that should
  199. be output along with the next message with C<partial> unset.
  200. Several partial messages can be stacked this way.
  201.  
  202. Duplicate filtering will apply to the I<global> message resulting from
  203. all I<partial> messages, using the options from the last (non-partial)
  204. message.  Linking associated messages is the main reason to use this
  205. option.
  206.  
  207. For instance the following messages
  208.  
  209.   msg 'channel', 'foo:2', 'redefinition of A ...';
  210.   msg 'channel', 'foo:1', '... A previously defined here';
  211.   msg 'channel', 'foo:3', 'redefinition of A ...';
  212.   msg 'channel', 'foo:1', '... A previously defined here';
  213.  
  214. will result in
  215.  
  216.  foo:2: redefinition of A ...
  217.  foo:1: ... A previously defined here
  218.  foo:3: redefinition of A ...
  219.  
  220. where the duplicate "I<... A previously defined here>" has been
  221. filtered out.
  222.  
  223. Linking these messages using C<partial> as follows will prevent the
  224. fourth message to disappear.
  225.  
  226.   msg 'channel', 'foo:2', 'redefinition of A ...', partial => 1;
  227.   msg 'channel', 'foo:1', '... A previously defined here';
  228.   msg 'channel', 'foo:3', 'redefinition of A ...', partial => 1;
  229.   msg 'channel', 'foo:1', '... A previously defined here';
  230.  
  231. Note that because the stack of C<partial> messages is printed with the
  232. first non-C<partial> message, most options of C<partial> messages will
  233. be ignored.
  234.  
  235. =back
  236.  
  237. =cut
  238.  
  239. use vars qw (%_default_options %_global_duplicate_messages
  240.          %_local_duplicate_messages);
  241.  
  242. # Default options for a channel.
  243. %_default_options =
  244.   (
  245.    type => 'warning',
  246.    exit_code => 1,
  247.    file => \*STDERR,
  248.    silent => 0,
  249.    uniq_scope => US_LOCAL,
  250.    uniq_part => UP_LOC_TEXT,
  251.    header => '',
  252.    footer => '',
  253.    backtrace => 0,
  254.    partial => 0,
  255.    );
  256.  
  257. # Filled with output messages as keys, to detect duplicates.
  258. # The value associated with each key is the number of occurrences
  259. # filtered out.
  260. %_local_duplicate_messages = ();
  261. %_global_duplicate_messages = ();
  262.  
  263. sub _reset_duplicates (\%)
  264. {
  265.   my ($ref) = @_;
  266.   my $dup = 0;
  267.   foreach my $k (keys %$ref)
  268.     {
  269.       $dup += $ref->{$k};
  270.     }
  271.   %$ref = ();
  272.   return $dup;
  273. }
  274.  
  275.  
  276. =head2 Functions
  277.  
  278. =over 4
  279.  
  280. =item C<reset_local_duplicates ()>
  281.  
  282. Reset local duplicate messages (see C<US_LOCAL>), and
  283. return the number of messages that have been filtered out.
  284.  
  285. =cut
  286.  
  287. sub reset_local_duplicates ()
  288. {
  289.   return _reset_duplicates %_local_duplicate_messages;
  290. }
  291.  
  292. =item C<reset_global_duplicates ()>
  293.  
  294. Reset local duplicate messages (see C<US_GLOBAL>), and
  295. return the number of messages that have been filtered out.
  296.  
  297. =cut
  298.  
  299. sub reset_global_duplicates ()
  300. {
  301.   return _reset_duplicates %_global_duplicate_messages;
  302. }
  303.  
  304. sub _merge_options (\%%)
  305. {
  306.   my ($hash, %options) = @_;
  307.   local $_;
  308.  
  309.   foreach (keys %options)
  310.     {
  311.       if (exists $hash->{$_})
  312.     {
  313.       $hash->{$_} = $options{$_}
  314.     }
  315.       else
  316.     {
  317.       confess "unknown option `$_'";
  318.     }
  319.     }
  320. }
  321.  
  322. =item C<register_channel ($name, [%options])>
  323.  
  324. Declare channel C<$name>, and override the default options
  325. with those listed in C<%options>.
  326.  
  327. =cut
  328.  
  329. sub register_channel ($;%)
  330. {
  331.   my ($name, %options) = @_;
  332.   my %channel_opts = %_default_options;
  333.   _merge_options %channel_opts, %options;
  334.   $channels{$name} = \%channel_opts;
  335. }
  336.  
  337. =item C<exists_channel ($name)>
  338.  
  339. Returns true iff channel C<$name> has been registered.
  340.  
  341. =cut
  342.  
  343. sub exists_channel ($)
  344. {
  345.   my ($name) = @_;
  346.   return exists $channels{$name};
  347. }
  348.  
  349. =item C<channel_type ($name)>
  350.  
  351. Returns the type of channel C<$name> if it has been registered.
  352. Returns The empty string otherwise.
  353.  
  354. =cut
  355.  
  356. sub channel_type ($)
  357. {
  358.   my ($name) = @_;
  359.   return $channels{$name}{'type'} if exists_channel $name;
  360.   return '';
  361. }
  362.  
  363. # _format_sub_message ($LEADER, $MESSAGE)
  364. # ---------------------------------------
  365. # Split $MESSAGE at new lines and add $LEADER to each line.
  366. sub _format_sub_message ($$)
  367. {
  368.   my ($leader, $message) = @_;
  369.   return $leader . join ("\n" . $leader, split ("\n", $message)) . "\n";
  370. }
  371.  
  372. # _format_message ($LOCATION, $MESSAGE, %OPTIONS)
  373. # -----------------------------------------------
  374. # Format the message.  Return a string ready to print.
  375. sub _format_message ($$%)
  376. {
  377.   my ($location, $message, %opts) = @_;
  378.   my $msg = '';
  379.   if (ref $location)
  380.     {
  381.       # If $LOCATION is a reference, assume it's an instance of the
  382.       # Autom4te::Location class and display contexts.
  383.       my $loc = $location->get || $me;
  384.       $msg = _format_sub_message ("$loc: ", $opts{'header'}
  385.                   . $message . $opts{'footer'});
  386.       for my $pair ($location->get_contexts)
  387.     {
  388.       $msg .= _format_sub_message ($pair->[0] . ":   ", $pair->[1]);
  389.     }
  390.     }
  391.   else
  392.     {
  393.       $location ||= $me;
  394.       $msg = _format_sub_message ("$location: ", $opts{'header'}
  395.                   . $message . $opts{'footer'});
  396.     }
  397.   return $msg;
  398. }
  399.  
  400. # Store partial messages here. (See the 'partial' option.)
  401. use vars qw ($partial);
  402. $partial = '';
  403.  
  404. # _print_message ($LOCATION, $MESSAGE, %OPTIONS)
  405. # ----------------------------------------------
  406. # Format the message, check duplicates, and print it.
  407. sub _print_message ($$%)
  408. {
  409.   my ($location, $message, %opts) = @_;
  410.  
  411.   return 0 if ($opts{'silent'});
  412.  
  413.   my $msg = _format_message ($location, $message, %opts);
  414.   if ($opts{'partial'})
  415.     {
  416.       # Incomplete message.   Store, don't print.
  417.       $partial .= $msg;
  418.       return;
  419.     }
  420.   else
  421.     {
  422.       # Prefix with any partial message send so far.
  423.       $msg = $partial . $msg;
  424.       $partial = '';
  425.     }
  426.  
  427.   # Check for duplicate message if requested.
  428.   if ($opts{'uniq_part'} != UP_NONE)
  429.     {
  430.       # Which part of the error should we match?
  431.       my $to_filter;
  432.       if ($opts{'uniq_part'} == UP_TEXT)
  433.     {
  434.       $to_filter = $message;
  435.     }
  436.       elsif ($opts{'uniq_part'} == UP_LOC_TEXT)
  437.     {
  438.       $to_filter = $msg;
  439.     }
  440.       else
  441.     {
  442.       confess "unknown value for uniq_part: " . $opts{'uniq_part'};
  443.     }
  444.  
  445.       # Do we want local or global uniqueness?
  446.       my $dups;
  447.       if ($opts{'uniq_scope'} == US_LOCAL)
  448.     {
  449.       $dups = \%_local_duplicate_messages;
  450.     }
  451.       elsif ($opts{'uniq_scope'} == US_GLOBAL)
  452.     {
  453.       $dups = \%_global_duplicate_messages;
  454.     }
  455.       else
  456.     {
  457.       confess "unknown value for uniq_scope: " . $opts{'uniq_scope'};
  458.     }
  459.  
  460.       # Update the hash of messages.
  461.       if (exists $dups->{$to_filter})
  462.     {
  463.       ++$dups->{$to_filter};
  464.       return 0;
  465.     }
  466.       else
  467.     {
  468.       $dups->{$to_filter} = 0;
  469.     }
  470.     }
  471.   my $file = $opts{'file'};
  472.   print $file $msg;
  473.   return 1;
  474. }
  475.  
  476. =item C<msg ($channel, $location, $message, [%options])>
  477.  
  478. Emit a message on C<$channel>, overriding some options of the channel  with
  479. those specified in C<%options>.  Obviously C<$channel> must have been
  480. registered with C<register_channel>.
  481.  
  482. C<$message> is the text of the message, and C<$location> is a location
  483. associated to the message.
  484.  
  485. For instance to complain about some unused variable C<mumble>
  486. declared at line 10 in F<foo.c>, one could do:
  487.  
  488.   msg 'unused', 'foo.c:10', "unused variable `mumble'";
  489.  
  490. If channel C<unused> is not silent (and if this message is not a duplicate),
  491. the following would be output:
  492.  
  493.   foo.c:10: unused variable `mumble'
  494.  
  495. C<$location> can also be an instance of C<Autom4te::Location>.  In this
  496. case the stack of contexts will be displayed in addition.
  497.  
  498. If C<$message> contains newline characters, C<$location> is prepended
  499. to each line.  For instance
  500.  
  501.   msg 'error', 'somewhere', "1st line\n2nd line";
  502.  
  503. becomes
  504.  
  505.   somewhere: 1st line
  506.   somewhere: 2nd line
  507.  
  508. If C<$location> is an empty string, it is replaced by the name of the
  509. program.  Actually, if you don't use C<%options>, you can even
  510. elide the empty C<$location>.  Thus
  511.  
  512.   msg 'fatal', '', 'fatal error';
  513.   msg 'fatal', 'fatal error';
  514.  
  515. both print
  516.  
  517.   progname: fatal error
  518.  
  519. =cut
  520.  
  521.  
  522. use vars qw (@backlog %buffering @chain);
  523.  
  524. # See buffer_messages() and flush_messages() below.
  525. %buffering = ();    # The map of channel types to buffer.
  526. @backlog = ();        # The buffer of messages.
  527.  
  528. sub msg ($$;$%)
  529. {
  530.   my ($channel, $location, $message, %options) = @_;
  531.  
  532.   if (! defined $message)
  533.     {
  534.       $message = $location;
  535.       $location = '';
  536.     }
  537.  
  538.   confess "unknown channel $channel" unless exists $channels{$channel};
  539.  
  540.   my %opts = %{$channels{$channel}};
  541.   _merge_options (%opts, %options);
  542.  
  543.   if (exists $buffering{$opts{'type'}})
  544.     {
  545.       push @backlog, [$channel, $location->clone, $message, %options];
  546.       return;
  547.     }
  548.  
  549.   # Print the message if needed.
  550.   if (_print_message ($location, $message, %opts))
  551.     {
  552.       # Adjust exit status.
  553.       if ($opts{'type'} eq 'error'
  554.       || $opts{'type'} eq 'fatal'
  555.       || ($opts{'type'} eq 'warning' && $warnings_are_errors))
  556.     {
  557.       my $es = $opts{'exit_code'};
  558.       $exit_code = $es if $es > $exit_code;
  559.     }
  560.  
  561.       # Die on fatal messages.
  562.       confess if $opts{'backtrace'};
  563.       exit $exit_code if $opts{'type'} eq 'fatal';
  564.     }
  565. }
  566.  
  567.  
  568. =item C<setup_channel ($channel, %options)>
  569.  
  570. Override the options of C<$channel> with those specified by C<%options>.
  571.  
  572. =cut
  573.  
  574. sub setup_channel ($%)
  575. {
  576.   my ($name, %opts) = @_;
  577.   confess "channel $name doesn't exist" unless exists $channels{$name};
  578.   _merge_options %{$channels{$name}}, %opts;
  579. }
  580.  
  581. =item C<setup_channel_type ($type, %options)>
  582.  
  583. Override the options of any channel of type C<$type>
  584. with those specified by C<%options>.
  585.  
  586. =cut
  587.  
  588. sub setup_channel_type ($%)
  589. {
  590.   my ($type, %opts) = @_;
  591.   foreach my $channel (keys %channels)
  592.     {
  593.       setup_channel $channel, %opts
  594.     if $channels{$channel}{'type'} eq $type;
  595.     }
  596. }
  597.  
  598. =item C<dup_channel_setup ()>, C<drop_channel_setup ()>
  599.  
  600. Sometimes it is necessary to make temporary modifications to channels.
  601. For instance one may want to disable a warning while processing a
  602. particular file, and then restore the initial setup.  These two
  603. functions make it easy: C<dup_channel_setup ()> saves a copy of the
  604. current configuration for later restoration by
  605. C<drop_channel_setup ()>.
  606.  
  607. You can think of this as a stack of configurations whose first entry
  608. is the active one.  C<dup_channel_setup ()> duplicates the first
  609. entry, while C<drop_channel_setup ()> just deletes it.
  610.  
  611. =cut
  612.  
  613. use vars qw (@_saved_channels);
  614. @_saved_channels = ();
  615.  
  616. sub dup_channel_setup ()
  617. {
  618.   my %channels_copy;
  619.   foreach my $k1 (keys %channels)
  620.     {
  621.       $channels_copy{$k1} = {%{$channels{$k1}}};
  622.     }
  623.   push @_saved_channels, \%channels_copy;
  624. }
  625.  
  626. sub drop_channel_setup ()
  627. {
  628.   my $saved = pop @_saved_channels;
  629.   %channels = %$saved;
  630. }
  631.  
  632. =item C<buffer_messages (@types)>, C<flush_messages ()>
  633.  
  634. By default, when C<msg> is called, messages are processed immediately.
  635.  
  636. Sometimes it is necessary to delay the output of messages.
  637. For instance you might want to make diagnostics before
  638. channels have been completely configured.
  639.  
  640. After C<buffer_messages(@types)> has been called, messages sent with
  641. C<msg> to a channel whose type is listed in C<@types> will be stored in a
  642. list for later processing.
  643.  
  644. This backlog of messages is processed when C<flush_messages> is
  645. called, with the current channel options (not the options in effect,
  646. at the time of C<msg>).  So for instance if some channel was silenced
  647. in the meantime, messages to this channels will not be print.
  648.  
  649. C<flush_messages> cancels the effect of C<buffer_messages>.  Following
  650. calls to C<msg> are processed immediately as usual.
  651.  
  652. =cut
  653.  
  654. sub buffer_messages (@)
  655. {
  656.   foreach my $type (@_)
  657.     {
  658.       $buffering{$type} = 1;
  659.     }
  660. }
  661.  
  662. sub flush_messages ()
  663. {
  664.   %buffering = ();
  665.   foreach my $args (@backlog)
  666.     {
  667.       &msg (@$args);
  668.     }
  669.   @backlog = ();
  670. }
  671.  
  672. =back
  673.  
  674. =head1 SEE ALSO
  675.  
  676. L<Autom4te::Location>
  677.  
  678. =head1 HISTORY
  679.  
  680. Written by Alexandre Duret-Lutz E<lt>F<adl@gnu.org>E<gt>.
  681.  
  682. =cut
  683.  
  684. 1;
  685.  
  686. ### Setup "GNU" style for perl-mode and cperl-mode.
  687. ## Local Variables:
  688. ## perl-indent-level: 2
  689. ## perl-continued-statement-offset: 2
  690. ## perl-continued-brace-offset: 0
  691. ## perl-brace-offset: 0
  692. ## perl-brace-imaginary-offset: 0
  693. ## perl-label-offset: -2
  694. ## cperl-indent-level: 2
  695. ## cperl-brace-offset: 0
  696. ## cperl-continued-brace-offset: 0
  697. ## cperl-label-offset: -2
  698. ## cperl-extra-newline-before-brace: t
  699. ## cperl-merge-trailing-else: nil
  700. ## cperl-continued-statement-offset: 2
  701. ## End:
  702.